perm filename POV2.2[EAL,HE] blob
sn#676476 filedate 1982-09-27 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00009 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 {$NOMAIN Auxilliary statement parsers }
C00005 00003 function returnParse(st: statementp): boolean external
C00008 00004 function affixParse(st: statementp): boolean external
C00014 00005 function unfixParse(st: statementp): boolean external
C00017 00006 function signlParse(st: statementp): boolean external
C00019 00007 function pauseParse(st: statementp): boolean external
C00020 00008 function printParse(st: statementp): boolean external
C00022 00009 function dimensionParse(st: statementp): boolean external
C00032 ENDMK
C⊗;
{$NOMAIN Auxilliary statement parsers }
%include palhdr.pas;
{ Externally defined routines from elsewhere: }
(* From ALLOC *)
function newNode: nodep; external;
procedure relNode(n: nodep); external;
(* From PROOT *)
procedure errprnt; external;
procedure getToken; external;
procedure getDelim(char: ascii); external;
procedure ppFlush; external;
function ov2ExprParse: nodep; external;
procedure ov2GetArgs(opn: nodep); external;
(* From PAUX1 *)
function makeNewVar(vartype: datatypes; vid: identp): varidefp; external;
function varLookup(id: identp): varidefp; external;
function getDtype(n: nodep): datatypes; external;
function checkArg(n: nodep; d: datatypes): nodep; external;
(* From PAUX2 *)
procedure relExpr(n: nodep); external;
function evalOrder(what,last: nodep; pcons: boolean): nodep; external;
function matchdim(d1,d2: nodep; exactp: boolean): boolean; external;
procedure checkdim(n,d: nodep); external;
function getdim(n: nodep; var d: nodep): nodep; external;
(* Display-related Routines *)
procedure ppLine; external;
procedure ppOutNow; external;
procedure ppChar(ch: ascii); external;
procedure pp5(ch: c5str; length: integer); external;
procedure pp10(ch: cstring; length: integer); external;
procedure pp10L(ch: cstring; length: integer); external;
procedure pp20(ch: c20str; length: integer); external;
procedure pp20L(ch: c20str; length: integer); external;
procedure ppInt(i: integer); external;
procedure ppReal(r: real); external;
procedure ppStrng(length: integer; s: strngp); external;
procedure ppDtype(d: datatypes); external;
procedure pOv2Get; external;
procedure pOv2Get; begin end;
function returnParse(st: statementp): boolean; external;
function returnParse;
var b: boolean; d: datatypes; dim1,dim2: nodep;
begin (* return statement *)
getToken;
b := (curProc = nil) or inCoblock or (curCmon <> nil); (* return ok here? *)
if b then
begin
pp20L('Can''t have a RETURN ',20); pp20('statement here. ',15);
ppFlush;
errprnt;
backup := true;
end
else
with curToken do
begin
st↑.rproc := curProc↑.p;
d := curProc↑.vtype;
if (ttype = delimtype) and (ch = '(') then (* returning a result? *)
begin
if d <> nulltype then
begin
st↑.retval := checkarg(ov2ExprParse,d);
dim1 := nil; (* now check that dimensions match *)
dim2 := nil;
if not matchdim(getdim(curProc↑.p,dim1),getdim(st↑.retval,dim2),dimCheck) then
begin
pp20L('Returning result of ',20); pp20('wrong dimension ',15);
errprnt;
end;
relNode(dim1);
relNode(dim2);
end
else
begin
st↑.retval := ov2ExprParse;
if st↑.retval <> nil then
begin
pp20L('Procedure doesn''t re',20); pp20('turn result! ',12);
errprnt;
end;
end;
getDelim(')'); (* look for closing ")" *)
end
else
begin
backup := true;
st↑.retval := nil;
if d <> nulltype then
begin
pp20L('Need a value to retu',20); pp10('rn with ',7);
errprnt;
end
end;
with st↑ do
if retval <> nil then exprs := evalOrder(retval,nil,true);
end;
returnParse := b;
end;
function affixParse(st: statementp): boolean; external;
function affixParse;
var opt,b: boolean; lexp: nodep;
begin (* affix statement *)
b := false;
opt := true;
with st↑, curToken do
begin
frame1 := checkarg(ov2ExprParse,frametype); (* get the first frame *)
frame2 := nil;
byvar := nil;
atexp := nil;
rigid := true; (* default flavor affixment *)
with frame1↑ do (* make sure it's a variable *)
begin
b := ((ntype <> leafnode) or (ltype <> varitype));
if b then b := ((ntype <> exprnode) or (op <> arefop));
end;
if b then
begin (* no good *)
pp20L('Need a frame variabl',20); pp10('e here. ',7); ppFlush;
end
else
begin
getToken; (* look for the "to" *)
if (ttype <> reswdtype) or (rtype <> filtype) or (filler <> totype) then
begin
b := true; (* no good *)
pp20L('Expecting a "TO" her',20); pp5('e. ',2); ppFlush;
end
else
begin (* so far so good *)
frame2 := checkarg(ov2ExprParse,frametype); (* get the other frame *)
with frame2↑ do (* make sure it's a variable *)
begin
b := ((ntype <> leafnode) or (ltype <> varitype));
if b then b := ((ntype <> exprnode) or (op <> arefop));
end;
if b then
begin (* no good *)
pp20L('Need a frame variabl',20); pp10('e here. ',7); ppFlush;
end
else
while opt and not b do
begin (* now look for optional parts: AT, BY & how *)
getToken;
if (ttype = reswdtype) and (rtype = filtype) and (filler = bytype) then
begin
byvar := checkarg(ov2ExprParse,transtype); (* get the BY var *)
checkdim(byvar,distancedim↑.dim);
with byvar↑ do (* make sure it's a variable *)
begin
b := ((ntype <> leafnode) or (ltype <> varitype));
if b then b := ((ntype <> exprnode) or (op <> arefop));
end;
if b then
begin (* no good *)
pp20L('Need a trans variabl',20); pp10('e here. ',7); ppFlush;
end
end
else if (ttype = reswdtype) and (rtype = filtype) and
(filler = attype) then
begin
atexp := checkarg(ov2ExprParse,transtype); (* get the AT expression *)
checkdim(atexp,distancedim↑.dim);
end
else if (ttype = reswdtype) and (rtype = filtype) and
(filler = rigidlytype) then rigid := true
else if (ttype = reswdtype) and (rtype = filtype) and
(filler = nonrigidlytype) then rigid := false
else
begin opt := false; backup := true end;
end;
with frame1↑ do
if ntype = leafnode then lexp := nil
else lexp := evalOrder(arg2,nil,true); (* push array subscripts *)
with frame2↑ do
if ntype <> leafnode then lexp := evalOrder(arg2,lexp,true);
if byvar <> nil then
with byvar↑ do
if ntype <> leafnode then lexp := evalOrder(arg2,lexp,true);
if atexp <> nil then exprs := evalOrder(atexp,lexp,true)
else exprs := lexp;
end;
end;
if b then (* bad statement - clean up a bit *)
begin
relExpr(frame1);
if frame2 <> nil then relExpr(frame2);
if byvar <> nil then relExpr(byvar);
if atexp <> nil then relExpr(atexp);
errprnt;
backup := true;
end;
end;
affixParse := b;
end;
function unfixParse(st: statementp): boolean; external;
function unfixParse;
var b: boolean; lexp: nodep;
begin (* unfix statement *)
b := false;
with st↑, curToken do
begin
frame1 := checkarg(ov2ExprParse,frametype); (* get the first frame *)
frame2 := nil;
byvar := nil;
atexp := nil;
with frame1↑ do (* make sure it's a variable *)
begin
b := ((ntype <> leafnode) or (ltype <> varitype));
if b then b := ((ntype <> exprnode) or (op <> arefop));
end;
if b then
begin (* no good *)
pp20L('Need a frame variabl',20); pp10('e here. ',7); ppFlush;
end
else
begin
getToken; (* look for the "from" *)
if (ttype <> reswdtype) or (rtype <> filtype) or
(filler <> fromtype) then
begin
b := true; (* no good *)
pp20L('Expecting a "FROM" h',20); pp5('ere. ',4); ppFlush;
end
else
begin (* so far so good *)
frame2 := checkarg(ov2ExprParse,frametype); (* get the other frame *)
with frame2↑ do (* make sure it's a variable *)
begin
b := ((ntype <> leafnode) or (ltype <> varitype));
if b then b := ((ntype <> exprnode) or (op <> arefop));
end;
if b then
begin (* no good *)
pp20L('Need a frame variabl',20); pp10('e here. ',7);ppFlush;
end
else
begin
with frame1↑ do
if ntype = leafnode then lexp := nil
else lexp := evalOrder(arg2,nil,true); (* push array subscripts *)
with frame2↑ do
if ntype <> leafnode then exprs := evalOrder(arg2,lexp,true)
else exprs := lexp;
end;
end;
end;
if b then (* bad statement - clean up a bit *)
begin
relExpr(frame1);
if frame2 <> nil then relExpr(frame2);
errprnt;
backup := true;
end;
end;
unfixParse := b;
end;
function signlParse(st: statementp): boolean; external;
function signlParse;
var b: boolean;
begin (* signal & wait statements *)
b := false;
with st↑ do
begin
event := checkarg(ov2ExprParse,eventtype); (* get the event to use *)
with event↑ do (* make sure it's a variable *)
b := not (((ntype = leafnode) and (ltype = varitype)) or
((ntype = exprnode) and (op = arefop)));
if b then
begin (* no good *)
pp20L('Need an event variab',20); pp10('le here. ',8); ppFlush;
errprnt;
backup := true;
relExpr(event);
end
else
with event↑ do
if ntype <> leafnode then exprs := evalOrder(arg2,nil,true);
end;
signlParse := b;
end;
function pauseParse(st: statementp): boolean; external;
function pauseParse;
var b: boolean;
begin (* pause statement *)
b := false;
with st↑ do
begin
ptime := ov2ExprParse; (* get pause time *)
if ptime = nil then
begin
b := true;
pp20L('Must specify how lon',20); pp20('g to pause. ',11); ppFlush;
errprnt;
end
else
begin
ptime := checkarg(ptime,svaltype); (* make sure it's of right type *)
checkdim(ptime,timedim↑.dim); (* and right dimension *)
exprs := evalOrder(ptime,nil,true);
end;
end;
pauseParse := b;
end;
function printParse(st: statementp): boolean; external;
function printParse;
var b: boolean;
begin (* print, prompt & abort statements *)
b := false;
with st↑ do
begin
pnode↑.arg2 := nil;
ov2Getargs(pnode); (* pretend we just saw a queryop *)
plist := pnode↑.arg2; (* store away pointer to print list *)
if plist <> nil then exprs := evalOrder(plist,nil,false)
else if stype = printtype then
begin
b := true;
pp20L('PRINT must have some',20); pp20('thing to print. ',15); ppFlush;
errprnt;
end;
debugLev := 0; (* for abort *)
end;
printParse := b;
end;
function dimensionParse(st: statementp): boolean; external;
function dimensionParse;
var b: boolean; v: varidefp; ndim: nodep;
function getdterm: nodep;
var n,np: nodep;
function getdfactor: nodep;
var n,np: nodep;
begin
n := newNode;
with n↑ do
begin
ntype := exprnode; (* assume expression *)
arg2 := nil;
arg3 := nil;
end;
getToken;
with curToken do
begin
if (ttype = reswdtype) and (rtype = clsetype) and
((clause = forcetype) or (clause = torquetype) or
(clause = angularvelocitytype) or (clause = velocitytype)) then
begin
ttype := identtype;
if clause = forcetype then id := forcedim↑.name
else if clause = torquetype then id := torquedim↑.name
else if clause = velocitytype then id := veldim↑.name
else id := angveldim↑.name;
end;
if (ttype = delimtype) and (ch = '(') then
begin
n↑.op := specop; (* special hack to keep parenthesis *)
n↑.arg1 := getdterm;
getDelim(')');
end
else if (ttype = reswdtype) and (rtype = optype) and (op = tinvrtop) then
begin
getDelim('(');
n↑.op := negop; (* special hack to use getdim routine *)
n↑.arg1 := getdterm;
getDelim(')');
end
else if (ttype = identtype) then
begin
n↑.ntype := leafnode;
n↑.ltype := varitype;
n↑.vari := varLookup(id);
n↑.vid := id;
if n↑.vari↑.vtype <> dimensiontype then (* no good *)
begin
pp20L('Can only have dimens',20); pp20('ion types here ',14);
errprnt;
end
end
else (* no good *)
begin
pp20L('Bad dimension expres',20); pp5('sion ',4);
errprnt;
relNode(n);
n := nil;
end
end;
getdfactor := n;
end;
begin {getdterm}
n := getdfactor;
getToken;
with curToken do
if (ttype = reswdtype) and (rtype = optype) and
((op = mulop) or (op = divop)) then
begin
np := newNode;
with np↑ do
begin
ntype := exprnode;
if curToken.op = mulop then op := smulop else op := sdivop;
arg1 := n;
arg2 := getdterm;
arg3 := nil;
end;
n := np;
end
else
begin
backup := true;
if (ttype <> delimtype) or ((ch <> ';') and (ch <> ')')) then
begin
pp20L('Bad dimension expres',20); pp5('sion.',5);
errprnt;
if n <> nil then relNode(n);
end;
end;
getdterm := n;
end;
begin {dimensionParse} (* dimension statement *)
b := false;
with st↑, curToken do
begin
getToken; (* get the name of the dimension type *)
if ttype <> identtype then
begin
b := true;
pp20L('Need an identifier h',20); pp5('ere. ',4);
errprnt;
end
else
begin
v := makeNewVar(dimensiontype,id);
dimname := v;
getToken; (* get "=" *)
if (ttype <> reswdtype) or (rtype <> optype) or (op <> seqop) then
begin
pp20L('Need an "=" here ',16);
errprnt;
backup := true;
end;
dimexpr := getdterm;
ndim := nil;
v↑.dim := getdim(dimexpr,ndim);
end;
end;
dimensionParse := b;
end;